home *** CD-ROM | disk | FTP | other *** search
/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / WIN_PRO / DS-1.ZIP;1 / RUNTIME.ZIP / IMISC.R < prev    next >
Encoding:
Text File  |  1992-02-10  |  6.5 KB  |  300 lines
  1. #if !COMPILER
  2. /*
  3.  * File: imisc.r
  4.  *  Contents: field, mkrec, limit, llist, bscan, escan
  5.  */
  6.  
  7. /*
  8.  * x.y - access field y of record x.
  9.  */
  10.  
  11. LibDcl(field,2,".")
  12.    {
  13.    register word fnum;
  14.    register struct b_record *rp;
  15.    register dptr dp;
  16.  
  17.    extern word *ftabp, *records;
  18.  
  19. #if MACINTOSH
  20. #if MPW
  21. /* #pragma unused(nargs) */
  22. #endif                    /* MPW */
  23. #endif                    /* MACINTOSH */
  24.  
  25.    Deref(Arg1);
  26.  
  27.    /*
  28.     * Arg1 must be a record and Arg2 must be a field number.
  29.     */
  30.    if (!is:record(Arg1)) 
  31.       RunErr(107, &Arg1);
  32.  
  33.    /*
  34.     * Map the field number into a field number for the record x.
  35.     */
  36.    rp = (struct b_record *) BlkLoc(Arg1);
  37.  
  38.  
  39.    fnum = ftabp[IntVal(Arg2) * *records + rp->recdesc->proc.recnum - 1];
  40.    /*
  41.     * If fnum < 0, x doesn't contain the specified field.
  42.     */
  43.    if (fnum < 0) 
  44.       RunErr(207, &Arg1);
  45.  
  46.    /*
  47.     * Return a pointer to the descriptor for the appropriate field.
  48.     */
  49.    dp = &rp->fields[fnum];
  50.    Arg0.dword = D_Var + ((word *)dp - (word *)rp);
  51.    VarLoc(Arg0) = (dptr)rp;
  52.    Return;
  53.    }
  54.  
  55.  
  56. /*
  57.  * mkrec - create a record.
  58.  */
  59.  
  60. LibDcl(mkrec,-1,"mkrec")
  61.    {
  62.    register int i;
  63.    register struct b_proc *bp;
  64.    register struct b_record *rp;
  65.  
  66.    /*
  67.     * Be sure that call is from a procedure.
  68.     */
  69.  
  70.    /*
  71.     * Get a pointer to the record constructor procedure and allocate
  72.     *  a record with the appropriate number of fields.
  73.     */
  74.    bp = (struct b_proc *) BlkLoc(Arg0);
  75.    Protect(rp = alcrecd((int)bp->nfields, (union block *)bp), RunErr(0,NULL));
  76.  
  77.    /*
  78.     * Set all fields in the new record to null value.
  79.     */
  80.    for (i = (int)bp->nfields; i > nargs; i--)
  81.       rp->fields[i-1] = nulldesc;
  82.  
  83.    /*
  84.     * Assign each argument value to a record element and dereference it.
  85.     */
  86.    for ( ; i > 0; i--) {
  87.       rp->fields[i-1] = Arg(i);
  88.       Deref(rp->fields[i-1]);
  89.       }
  90.  
  91.    ArgType(0) = D_Record;
  92.    Arg0.vword.bptr = (union block *)rp;
  93.    Return;
  94.    }
  95.  
  96. /*
  97.  * limit - explicit limitation initialization.
  98.  */
  99.  
  100.  
  101. LibDcl(limit,2,BackSlash)
  102.    {
  103.  
  104.    C_integer tmp;
  105.  
  106. #if MACINTOSH
  107. #if MPW
  108. /* #pragma unused(nargs) */
  109. #endif                    /* MPW */
  110. #endif                    /* MACINTOSH */
  111.  
  112.    /*
  113.     * The limit is both passed and returned in Arg0.  The limit must
  114.     *  be an integer.  If the limit is 0, the expression being evaluated
  115.     *  fails.  If the limit is < 0, it is an error.  Note that the
  116.     *  result produced by limit is ultimately picked up by the lsusp
  117.     *  function.
  118.     */
  119.    Deref(Arg0);
  120.  
  121.    if (!cnv:C_integer(Arg0,tmp))
  122.       RunErr(101, &Arg0);
  123.    MakeInt(tmp,&Arg0);
  124.  
  125.    if (IntVal(Arg0) < 0) 
  126.       RunErr(205, &Arg0);
  127.    if (IntVal(Arg0) == 0)
  128.       Fail;
  129.    Return;
  130.    }
  131.  
  132. /*
  133.  * bscan - set &subject and &pos upon entry to a scanning expression.
  134.  *
  135.  *  Arguments are:
  136.  *    Arg0 - new value for &subject
  137.  *    Arg1 - saved value of &subject
  138.  *    Arg2 - saved value of &pos
  139.  *
  140.  * A variable pointing to the saved &subject and &pos is returned to be
  141.  *  used by escan.
  142.  */
  143.  
  144. LibDcl(bscan,2,"?")
  145.    {
  146.    char sbuf[MaxCvtLen];
  147.    int rc;
  148.    struct pf_marker *cur_pfp;
  149.  
  150. #if MACINTOSH
  151. #if MPW
  152. /* #pragma unused(nargs) */
  153. #endif                    /* MPW */
  154. #endif                    /* MACINTOSH */
  155.  
  156.    /*
  157.     * Convert the new value for &subject to a string.
  158.     */
  159.    Deref(Arg0);
  160.  
  161.    if (!cnv:string(Arg0,Arg0))
  162.       RunErr(103, &Arg0);
  163.  
  164.    /*
  165.     * Establish a new &subject value and set &pos to 1.
  166.     */
  167.    k_subject = Arg0;
  168.    k_pos = 1;
  169.  
  170.    /* If the saved scanning environment belongs to the current procedure
  171.     *  call, put a reference to it in the procedure frame.
  172.     */
  173.    if (pfp->pf_scan == NULL)
  174.       pfp->pf_scan = &Arg1;
  175.    cur_pfp = pfp;
  176.  
  177.    /*
  178.     * Suspend with a variable pointing to the saved &subject and &pos.
  179.     */
  180.    ArgType(0) = D_Var;
  181.    VarLoc(Arg0) = &Arg1;
  182.  
  183.    rc = interp(G_Csusp,cargp);
  184.  
  185.    if (pfp != cur_pfp)
  186.       return rc;
  187.  
  188.    /*
  189.     * Leaving scanning environment. Restore the old &subject and &pos values.
  190.     */
  191.    k_subject = Arg1;
  192.    k_pos = IntVal(Arg2);
  193.    if (pfp->pf_scan == &Arg1)
  194.       pfp->pf_scan = NULL;
  195.  
  196.    if (rc == A_Resume)
  197.       return A_Resume;
  198.    else
  199.       return rc;
  200.  
  201.    }
  202.  
  203. /*
  204.  * escan - restore &subject and &pos at the end of a scanning expression.
  205.  *
  206.  *  Arguments:
  207.  *    Arg0 - variable pointing to old values of &subject and &pos
  208.  *    Arg1 - result of the scanning expression
  209.  *
  210.  * The two arguments are reversed, so that the result of the scanning
  211.  *  expression becomes the result of escan. This result is dereferenced
  212.  *  if it refers to &subject or &pos. Then the saved values of &subject
  213.  *  and &pos are exchanged with the current ones.
  214.  *
  215.  * Escan suspends once it has restored the old &subject; on failure
  216.  *  the new &subject and &pos are "unrestored", and the failure is
  217.  *  propagated into the using clause.
  218.  */
  219.  
  220. LibDcl(escan,1,"escan")
  221.    {
  222.    struct descrip tmp;
  223.    int rc;
  224.    struct pf_marker *cur_pfp;
  225.  
  226. #if MACINTOSH
  227. #if MPW
  228. /* #pragma unused(nargs) */
  229. #endif                    /* MPW */
  230. #endif                    /* MACINTOSH */
  231.  
  232.    /*
  233.     * Copy the result of the scanning expression into Arg0, which will
  234.     *  be the result of the scan.
  235.     */
  236.    tmp = Arg0;
  237.    Arg0 = Arg1;
  238.    Arg1 = tmp;
  239.  
  240.    /*
  241.     * If the result of the scanning expression is &subject or &pos,
  242.     *  it is dereferenced. #%#%  following is incorrect #%#%
  243.     */
  244.    /*if ((Arg0 == k_subject) ||
  245.       (Arg0 == kywd_pos))
  246.          Deref(Arg0); */
  247.  
  248.    /*
  249.     * Swap new and old values of &subject
  250.     */
  251.    tmp = k_subject;
  252.    k_subject = *VarLoc(Arg1);
  253.    *VarLoc(Arg1) = tmp;
  254.  
  255.    /*
  256.     * Swap new and old values of &pos
  257.     */
  258.    tmp = *(VarLoc(Arg1) + 1);
  259.    IntVal(*(VarLoc(Arg1) + 1)) = k_pos;
  260.    k_pos = IntVal(tmp);
  261.  
  262.    /*
  263.     * If we are returning to the scanning environment of the current 
  264.     *  procedure call, indicate that it is no longed in a saved state.
  265.     */
  266.    if (pfp->pf_scan == VarLoc(Arg1))
  267.       pfp->pf_scan = NULL;
  268.    cur_pfp = pfp;
  269.  
  270.    /*
  271.     * Suspend the value of the scanning expression.
  272.     */
  273.  
  274.    rc = interp(G_Csusp,cargp);
  275.  
  276.    if (pfp != cur_pfp)
  277.       return rc;
  278.  
  279.    /*
  280.     * Re-entering scanning environment, exchange the values of &subject
  281.     *  and &pos again
  282.     */
  283.    tmp = k_subject;
  284.    k_subject = *VarLoc(Arg1);
  285.    *VarLoc(Arg1) = tmp;
  286.  
  287.    tmp = *(VarLoc(Arg1) + 1);
  288.    IntVal(*(VarLoc(Arg1) +1)) = k_pos;
  289.    k_pos = IntVal(tmp);
  290.  
  291.    if (pfp->pf_scan == NULL)
  292.       pfp->pf_scan = VarLoc(Arg1);
  293.  
  294.    if (rc == A_Resume)
  295.       return A_Resume;
  296.    else
  297.       return rc;
  298.    }
  299. #endif                    /* !COMPILER */
  300.